{-# OPTIONS_GHC -XRecordWildCards #-}
module XI.Directory.WS.ProxyWSDL {-(gen_proxy)-} where

import XI.Directory.WS.Types
import Data.List
import Data.Char
import Text.XML.Light.Types
import qualified Data.Map as Map

types_list :: [WsOper] -> [WsType]
types_list opers = nub $ [WsComplexType name alias elems |
        WsOper {..} <- opers,
        (io, WsComplexType {..}) <- [("Input", wselType wsopInput ), ("Output", wselType wsopOutput)],
        (name, alias, elems) <- get_types (wsopName ++ io, wsopName ++ io, wsctElems)
    ]
    where
        get_types (n, a, es) = [(n, a, map f es)] ++ concatMap g es
        f e = e { wselType = 
                case wselType e of
                    WsComplexType "" a' es' -> WsComplexType "" a' es'
                    WsComplexType n' a' _ -> WsComplexType n' a' []
                    st -> st
                }
        g (WsElem {..}) = case wselType of
                WsComplexType n' a' es' -> get_types (n', a', es')
                _ -> []

lowerFirst (s:ss) = (toLower s) : ss
upperFirst (s:ss) = (toUpper s) : ss

aliasToElName (WsElem {..}) name = lowerFirst $ if wselAlias == wselName then wselAlias ++ upperFirst name else wselAlias

gen_type :: WsType -> String
gen_type (WsComplexType {..}) = 
    let 
        up = upperFirst wsctAlias
        me = map f wsctElems
    in
    "data " ++ up  ++ " = " ++ up ++ " {\n" ++ (unlines $ init me ++ [init $ last me]) ++ "} deriving (Typeable, Show, Eq) \n"
    where 
        f e@(WsElem {..}) = replicate 4 ' '
            ++ aliasToElName e wsctName ++ " :: "
            ++ (if wselNillable then "Maybe " else "")
            ++ (if wselMaxOccurs == Unbounded then "[" else "")
            ++ case wselType of
                WsComplexType {..} -> upperFirst wsctAlias
                WsSimpleType "string" -> "String"
                WsSimpleType "boolean" -> "Bool"
                WsSimpleType "dateTime" -> "LocalTime"
                x -> error $ "Unknown type " ++ (show x) ++ "in function \"gen_type -> f\"\n"
            ++ (if wselMaxOccurs == Unbounded then "]" else "") 
            ++ ","
            
gen_type _ = ""

gen_instance :: WsType -> String
gen_instance (WsComplexType {..}) = 
    "\ninstance Xmlable " ++ ufName ++ " where" ++
    "\n\ttoContent x = [makeToContent " ++ els ++ " [" ++ ns' 2 (\e->", toContent." ++ aliasToElName e wsctName) ++ "] x]" ++
    "\n\tfromContent cs = " ++ ufName ++ " " ++ (ns 2 ") (fromContent c") ++ ")" ++
    "\n\t\twhere [" ++ (ns 2 ", c") ++ "] = forFromContent nss " ++ els ++ " cs"
    where
        ufName = upperFirst wsctAlias
        ns' n f = drop n . concatMap f $ wsctElems
        ns n s = drop n . concat . zipWith (\n _-> s ++ (show n)) [1..] $ wsctElems
        els = ("[" ++) . (++ "]") . drop 2 . concatMap (\(WsElem {..})->", \""++ wselPrefix ++ ":" ++ wselName ++ "\"") $ wsctElems

gen_instance _ = ""

gen_proxy :: WsDescr -> String
gen_proxy (WsDescr {..}) = 
    "{-# OPTIONS_GHC -XDeriveDataTypeable #-}\n" ++ 
    "module " ++ wsdName ++ " where\n" ++ 
    (imp "Data" ["List", "Maybe", "Typeable", "Time.LocalTime"]) ++
    (imp "XI.Directory.WS" ["Xmlable", "Main"]) ++ "\n" ++
    "ws = " ++ show wsdName ++ "\n" ++ 
    "nss = " ++ show wsdNamespaces ++ "\n\n" ++ 
    "-- operations\n\n" ++
    unlines (map f wsdOpers) ++ "\n\n" ++
    "-- types definition\n\n" ++
    unlines (map gen_type tl) ++ "\n\n" ++
    "-- instances\n\n"  ++
    unlines (map gen_instance tl) ++ "\n"
    where
        tl = types_list wsdOpers
        imp pref = concatMap ((("import " ++ pref ++ ".") ++).(++"\n"))
        f o = lf ++ " :: WsParams -> " ++ uf ++ "Input" ++ " -> IO " ++ uf ++ "Output\n" ++
            lf ++ " = runService ws nss " ++ (show (prefTNS ++ ":" ++ lf))
            where
                lf = lowerFirst $ wsopName o
                uf = upperFirst $ wsopName o
                prefTNS = wselPrefix $ wsopInput o
                